perm filename TOP4[AM,DBL]3 blob
sn#172399 filedate 1975-08-10 generic text, type T, neo UTF8
(FILECREATED "10-AUG-75 17:44:01" <LENAT>TOP4.;32 37958
changes to: APPLYB CLEAN CLEANALL CON-MERGE-ARGS CREATEB INSTAN-1D IS-ONE-OF MAPAPPEND ONLY-COMS RECTANGLE
SIMULT-SATISFY UPDATE VERBOSITY
previous date: " 9-AUG-75 20:04:42" <LENAT>TOP4.;31)
(LISPXPRINT (QUOTE TOP4COMS)
T T)
[RPAQQ TOP4COMS
((FNS ACCESS ADD-CANDS ALL-BUT-LAST ALLQ ANY1OF ANY1OF-SATISFYING ANY1OFE ANY1SAT APPLYB APPLYB-P ARE-EQUIV
ARG-CHECK ARG-SUBST ARGS-ASA AVG2 BPFS CLEAN CLEANALL COM-ANCES COMMENT CON-MERGE-ARGS CPRIN1 CREATEB
DE-THRESH DECRB DEFB DEFP DIE DOTPROD DWIMUSERFN ENSURE ENSURE-TOP EVERY2 FAN FIND-NEW-CANDS FIRSTN
FLATTEN FRAC-INCLU FSET-NTH GATH GCB GEN-FNAME GET-TIME GETARGS GETB GETB-P GETB-P-C GETBQ GETU GEXADD
GEXEC GLUE GLUEC GLUEE GPGM-PRIN GTRANSFER IN-FACTOR INCRB INIT-PART INSTAN-1D INSTAN-1I INSTAN-1S
INSTAN-BASE INSTAN-D INSTAN-I INSTAN-PAT INSTAN-REC INSTAN-S INT-ENUF IS-CON IS-CON-L IS-ONE-OF ISA
JUST-ONCE KINDS-OF LESS-INT LRU-TAG M2 MAPAPPEND MAX MAX1 MAX2 MIN2 MKSWAPP MORE-GENERAL MORE-INT
MORE-SPECIFIC NCONCB ONE-ISA ONLY-COMS PGET PICK-CAND POR PRUNABLE PRUNE PSUF PUTB PUTU PXEQ Q RAND-CON
RAND-MEMB RAND-OBJ RAND-PERMUTE RAND-PRED RAND-SUBSET RAND-THING RAND-USER RE-JUDGE RECENTLY-TRIED
RECTANGLE REM-ONCE RIPPLE RIPPLE-SIMULT RIPPLE-UNTIL RIPPLE1 RMUL SAME-TYPE SATISFIES SELF SELF-COMPILE
SEQX SET-DIFF SET-NTH SETB SETBQ SIMULT-SATISFY SOME-EBP SOMEE SORD SSORT START SUB-CANDS SUB-ONCE
SUBSET-INVOLVING-ONLY SWAPB SWGETB SWITCH SWSETB TLOOP TYPE UNDO-INIT UNFORGETTABLE UNPRUNABLE UP-THRESH
UPDATE XEQ-CAND XTR-BEING)
(FNS INIT1 INIT-COMP)
BA-LIST BA-LIST2 CAND-TAIL COMMA CONSTRUCTIVE-OPS CRLF DO-THRESH DWIMUSERFN EX-THRESH F-COUNTER INIT-CANDS
INIT-ONCE-LIST INIT-PAST INIT-DOTHRESH INIT-EXTHRESH INIT-INT-THRESH INIT-INTHRESH INT-THRESH INTHRESH JTRASH
RANDSTATE TOP-ACTS TRIVB USERNAMES VERBOSITY (P (INIT1)
(INIT-COMP))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA TYPE COMMENT ANY1OF)
(NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE Q JUST-ONCE GETBQ ANY1SAT ALLQ]
(DEFINEQ
(ACCESS
[LAMBDA (A)
A])
(ADD-CANDS
[LAMBDA (C)
(SETQ CANDS (NCONC C CANDS])
(ALL-BUT-LAST
[LAMBDA (L)
(LDIFF L (FLAST L])
(ALLQ
[NLAMBDA (L)
(COND
((NLISTP L)
(KWOTE L))
((CONS (QUOTE LIST)
(MAPCAR L (QUOTE ALLQ])
(ANY1OF
[NLAMBDA Z (* EVAL (RAND-MEMB Z))
(EVAL (CAR Z])
(ANY1OF-SATISFYING
[LAMBDA (XSET TST X)
(AND (SETQ X (RAND-MEMB XSET))
(OR (EVAL TST)
(ANY1OF-SATISFYING (REMOVE X XSET)
TST])
(ANY1OFE
[LAMBDA (L)
(CAR L])
(ANY1SAT
[NLAMBDA (XSET TST)
(ANY1OF-SATISFYING (EVAL XSET)
TST])
(APPLYB-P
[LAMBDA (B)
(APPLYB B P BA1 BA2 BA3 BA4])
(ARE-EQUIV
[LAMBDA (X1 X2)
(OR (EQUAL X1 X2)
(MEMBER (LIST (QUOTE EQUIV)
X1)
(GETB X2 (QUOTE TIES)))
(INTERSECTION (GETB X1 (QUOTE DEFN))
(GETB X2 (QUOTE DEFN)))
(INTERSECTION (GETB X1 (QUOTE ALGS))
(GETB X2 (QUOTE ALGS)))
(ADD-CANDS (LIST (LIST CS-INT (QUOTE FILLIN)
(QUOTE PROVE)
(LIST (QUOTE FORALL)
(QUOTE ARGS)
(LIST (QUOTE EQUAL)
(KWOTE BA1)
(KWOTE BA2)))
(QUOTE INDUCTIVELY))
(CONS (SUB1 CS-INT)
(APPEND (CDR CAND)
(LIST (QUOTE DO-AGAIN])
(ARG-CHECK
[LAMBDA (A B)
(EVERY2 [CDR (ANY1OF (GETB B (QUOTE D-R]
A
(QUOTE DEFN])
(ARG-SUBST
[LAMBDA (ARG1 NEW1 ARG2 NEW2)
[SET ARG1 (CAR (DSUBST NEW1 ARG1 (DSUBST NEW1 (LIST (QUOTE COPY)
ARG1)
(DSUBST NEW2 ARG2 (DSUBST NEW2 (LIST (QUOTE COPY)
ARG2)
(LIST (COPY (EVAL ARG1]
(SET ARG2 (CAR (DSUBST NEW1 ARG1 (DSUBST NEW1 (LIST (QUOTE COPY)
ARG1)
(DSUBST NEW2 ARG2 (DSUBST NEW2 (LIST (QUOTE COPY)
ARG2)
(LIST (COPY (EVAL ARG2])
(ARGS-ASA
[LAMBDA (BNAME ARGSET) (* HERE WE ARE SUPPOSED TO LOCATE THE
D-R PART OF BNAME, AND BIND THE
ARGUMENTS ON (CDR OF) ARGLIST AS
SPECIFIED IN THAT D-R PART)
(HELP "ARGS-ASA IS NOT IN YET. SORRY. "])
(AVG2
[LAMBDA (N1 N2)
(IQUOTIENT (IPLUS N1 N2)
2])
(BPFS
[LAMBDA (B)
(CDDR (CADDR (GETD B])
(CLEAN
[LAMBDA (P1 P2 P1I P2I)
(SETQ P2I (GETB (GLUE (QUOTE ANYB)
P2)
(QUOTE INIT)))
(MAPC CONCEPTS (FUNCTION (LAMBDA (C)
(MAPC (GETB C P1)
(FUNCTION (LAMBDA (B)
(AND (IS-CON B)
(PUT B P2 (APPEND P2I (UNION (LIST C)
(GETB B P2])
(CLEANALL
[LAMBDA NIL
(CLEAN (QUOTE SPEC)
(QUOTE GENL))
(CLEAN (QUOTE GENL)
(QUOTE SPEC))
(CLEAN (QUOTE UP)
(QUOTE EXS])
(COM-ANCES
[LAMBDA (B1 B2 ANLIST)
[MAP2C (DREVERSE (RIPPLE B1 (QUOTE GENL)))
(DREVERSE (RIPPLE B2 (QUOTE GENL)))
(FUNCTION (LAMBDA (AN1 AN2)
(AND (EQ AN1 AN2)
(SETQ ANLIST (CONS AN1 ANLIST]
ANLIST])
(COMMENT
[NLAMBDA X
(CONS (QUOTE COMMENT)
X])
(CON-MERGE-ARGS
[LAMBDA (F1 F2 F12 PGM1 SCHK SAPL DOM1 DOM2 RAN1 RAN2)
[SETQ RAN1 (LAST (CAR (GETB F1 (QUOTE D-R]
(SETQ DOM1 (LDIFF (CAR (GETB F1 (QUOTE D-R)))
RAN1))
[SETQ RAN2 (LAST (CAR (GETB F2 (QUOTE D-R]
(SETQ DOM2 (LDIFF (CAR (GETB F2 (QUOTE D-R)))
RAN2)) (* SETQ DOM3 (AND (CDR DOM1)
(LIST (CADR (MIN2 (APPEND RAN2 RAN2 RAN2
RAN2) DOM1 (QUOTE FRAC-INCLU))))))
(COMMENT AS DOMi AND RANi ARE LOCATED, SWITCHING OF ARGS MAY BE REQUIRED, INSIDE PGM1)
(* AND (MEMB (CAR DOM3) DOM2)
(SETQ DOM3 NIL))
(SETQ GTEMP20 (LENGTH DOM2))
[SETQ SAPL (LIST (QUOTE RETURN)
(NCONC (LIST (QUOTE APPLYB)
(KWOTE F1)
(Q ALGS))
(MAPCAR (SUB-ONCE (QUOTE X)
[SETQ GTEMP19 (COND
((FMEMB (CAR RAN2)
DOM1)
(CAR RAN2))
((IS-ONE-OF (CAR RAN2)
DOM1))
((SETQ SCHK (ONE-ISA DOM1 (CAR RAN2]
DOM1)
(FUNCTION (LAMBDA (Z)
(COND
((EQ Z (QUOTE X))
(QUOTE X))
(T (SETQ GTEMP20 (ADD1 GTEMP20))
(CAR (FNTH BA-LIST GTEMP20]
[SETQ PGM1 (LIST (QUOTE PROG)
(LIST (QUOTE X))
[LIST (QUOTE SETQ)
(QUOTE X)
(NCONC (LIST (QUOTE APPLYB)
(KWOTE F2)
(Q ALGS))
(FIRSTN (LENGTH DOM2)
(LIST (QUOTE BA1)
(QUOTE BA2)
(QUOTE BA3]
(COND
(SCHK (LIST (QUOTE AND)
(LIST (QUOTE ARG-CHECK)
(QUOTE X)
(KWOTE SCHK))
SAPL))
(T SAPL]
(SETQ DOM3 (REM-ONCE GTEMP19 DOM1))
(LIST (LIST (QUOTE OSET)
(APPEND DOM2 DOM3 RAN1))
PGM1])
(CPRIN1
[LAMBDA CPARG
(AND (IGREATERP VERBOSITY (ARG CPARG 1))
(FOR CPI FROM 2 TO CPARG DO (PRIN1 (ARG CPARG CPI])
(CREATEB
[LAMBDA (B)
(ATTACH B CONCEPTS)
(PUTHASH B 1 HCON)
(SETQ FIXEDCONS (UNION (LIST B)
FIXEDCONS)) (* XEQ-CLEAN B)
(PUTD B (COPY TRIVB])
(DE-THRESH
[LAMBDA NIL
(SETQ DO-THRESH (IQUOTIENT (ITIMES DO-THRESH 2)
3))
(CPRIN1 7 " DO-THRESH REDUCED TO " DO-THRESH CRLF)
DO-THRESH])
(DECRB
[LAMBDA (B P X)
(AND X (DREMOVE X (GETB B P])
(DEFB
[LAMBDA (B)
[MAPC XS-PARTS (FUNCTION (LAMBDA (XP BP)
(COND
((GETB B XP)
(SETQ BP (GLUEE B XP))
(OR (ASSOC XP (BPFS B))
(ATTACH (LIST XP (CONS BP (GETARGS XP)))
(BPFS B)))
(PUTD BP (LIST (QUOTE LAMBDA)
(GETARGS XP)
(LIST (QUOTE SELF-COMPILE)
BP
(FGETB B XP]
(AND (GETB B (QUOTE ALGS))
(NULL (GETB B (QUOTE INV)))
(ATTACH [LIST (QUOTE INV)
(CONS (GLUEE B (QUOTE ALGS))
(GETARGS (QUOTE ALGS]
(BPFS B])
(DEFP
[LAMBDA (F)
(PUTD F (LIST (QUOTE NLAMBDA)
(CONS (QUOTE B)
(AND (FMEMB F XEQ-PARTS)
(GETARGS F)))
(COND
[(FMEMB F SUF-PARTS)
(PUT F (QUOTE INFO)
(QUOTE EVAL))
(CONS (QUOTE PSUF)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
[(FMEMB F OR-PARTS)
(CONS (QUOTE POR)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
[(FMEMB F XEQ-PARTS)
(PUT F (QUOTE INFO)
(QUOTE EVAL))
(CONS (QUOTE PXEQ)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
(T (LIST (QUOTE PGET)
(KWOTE F)
(QUOTE B])
(DIE
[LAMBDA (MES)
(CPRIN1 -1 CRLF CRLF "*********** AM FATAL COLLAPSE *********** " CRLF MES CRLF CRLF)
(HELP])
(DOTPROD
[LAMBDA (V1 V2)
(OR [AND V1 V2 (PLUS (TIMES (EVAL (CAR V1))
(EVAL (CAR V2)))
(DOTPROD (CDR V1)
(CDR V2]
0])
(DWIMUSERFN
[LAMBDA (X1 X3)
(AND (MATCH (UNPACK FAULTX) WITH (X1←--
'- 'E '- X3←--))
(GETHASH (SETQ X1 (PACK X1))
HCON)
(FMEMB (SETQ X3 (PACK X3))
XEQ-PARTS)
[DEFINE (LIST (LIST FAULTX (LIST (QUOTE LAMBDA)
(GETARGS X3)
(LIST (QUOTE SELF-COMPILE)
X1
(GETB X1 X3]
(CONS FAULTX FAULTARGS])
(ENSURE
[LAMBDA (B P)
(OR (AND (OR (MEMB P FACETS)
(MEMB [PACK (DREVERSE (CDR (DREVERSE (UNPACK P]
FACETS))
(OR (GETHASH B HCON)
(CREATEB B))
(OR (GETB B P)
(INIT-PART B P)))
(CPRIN1 1 "*** WARNING: B,P are not accessable: " B COMMA P CRLF])
(ENSURE-TOP
[LAMBDA NIL
(OR (AND (OR (MEMB CS-P FACETS)
(MEMB [PACK (DREVERSE (CDR (DREVERSE (UNPACK CS-P]
FACETS))
(OR (GETHASH CS-B HCON)
(CREATEB CS-B))
(MEMB CS-OP TOP-ACTS))
(CPRIN1 1 "*** WARNING: CS OP,B,P aren't meaningful (yet):" CRLF CS-OP COMMA CS-B COMMA CS-P])
(EVERY2
[LAMBDA (X Y F)
(OR (NULL X)
(NULL Y)
(AND (APPLY* F (CAR X)
(CAR Y))
(EVERY2 (CDR X)
(CDR Y)
F])
(FAN
[LAMBDA (MSET MPAR MB1)
(CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
(APPLYB MS1 MPAR MB1])
(FIND-NEW-CANDS
[LAMBDA NIL
(CPRIN1 6 " MUST FIND NEW CANDS " CRLF)
(SETQ INTHRESH (IN-FACTOR DO-THRESH))
(ADD-CANDS (MAPCONC CONCEPTS (QUOTE UNFORGETTABLE])
(FIRSTN
[LAMBDA (N L)
(LDIFF L (FNTH L (ADD1 N])
(FLATTEN
[LAMBDA (L)
(COND
((NLISTP L)
(LIST L))
((MAPCONC L (QUOTE FLATTEN])
(FRAC-INCLU
[LAMBDA (B1 B2)
(COND
((EQ B1 B2)
100)
((ISA B1 B2)
99)
((ISA B2 B1)
50)
(T (* NOTICE HOW CRUDE THIS IS.
IMPROVE IT!!)
0])
(FSET-NTH
[LAMBDA (S N X)
(CAR (FRPLACA (FNTH S N)
X])
(GATH
[LAMBDA (B GENB GENP)
(* the old version was: COND ((SETQ GENB (CAR (APPLYB B
(QUOTE UP) (QUOTE FILLIN)))) (COND ((GETHASH (SETQ GENP
(GLUE GENB GATH-PART)) HCON) (ATTACH GENP GPGM))) (COND
((GETHASH (SETQ GENP (GLUE GENB (QUOTE ANYP))) HCON)
(ATTACH GENP GPGM))) (GATH GENB)))
(RIPPLE B GATH-PART (QUOTE GENL])
(GCB
[LAMBDA (N)
[MAPC ONCE-LIST (FUNCTION (LAMBDA (C)
(SETB (CAR C)
(CDR C)
(REMOVE JTRASH (GETB (CAR C)
(CDR C]
(SETQ ONCE-LIST INIT-ONCE-LIST)
(FOR GCX IN (SORT (COPY CONCEPTS)
(QUOTE GET-TIME))
AS GCI FROM 1 TO N DO (SWAPB GCX])
(GEN-FNAME
[LAMBDA (A B)
(PACK (LIST (QUOTE F)
A
(QUOTE -)
B
(QUOTE -)
(SETQ F-COUNTER (ADD1 F-COUNTER])
(GET-TIME
[LAMBDA (B)
(GETU B (QUOTE TIME])
(GETARGS
[LAMBDA (P)
(GETP P (QUOTE ARGS])
(GETB
[LAMBDA (B P)
(UNDO-INIT P (GETP B P])
(GETB-P
[LAMBDA (B)
(GETB B P])
(GETB-P-C
[LAMBDA (B)
(COPY (GETB B P])
(GETBQ
[NLAMBDA (B P)
(GETP B P])
(GETU
[LAMBDA (B PROP)
(GET (GETTOPVAL B)
PROP])
(GEXADD
[LAMBDA (X)
(SETQ GEXISTING (UNION GEXISTING X))
X])
(GEXEC
[LAMBDA (GB)
(APPLYB GB GPNAME])
(GLUE
[LAMBDA (B P) (* A more sophisticated scheme can be
implemented: e.g., using HASHing)
(PACK (LIST B (QUOTE -)
P])
(GLUEC
[LAMBDA (B1 B2)
(PACK (LIST (QUOTE COMPOSE-)
B1
(QUOTE &)
B2])
(GLUEE
[LAMBDA (B P) (* A more sophisticated scheme can be
implemented: e.g., using HASHing)
(PACK (LIST B (QUOTE -E-)
P])
(GPGM-PRIN
[LAMBDA (GFN GNAM)
(COND
[(CDR GPGM)
(DREMOVE T GPGM)
(CPRIN1 9 " The (G)pgm to " GNAM CRLF CS-B COMMA CS-P " is:" CRLF GPGM)
(SETQ GPNAME (GETHASH GNAM SUF1))
(MAPC GPGM GFN)
(SETQ GPNAME (GETHASH GNAM SUF2))
(MAPC (DREVERSE GPGM)
GFN)
(ADD-CANDS (LIST (LIST 400 (QUOTE RE-JUDGE)
(LIST CS-B CS-P]
((CPRIN1 3 CRLF "***** WARNING: UNABLE TO FIND ANY INFO RELE TO " GNAM " THE " CS-P " PART OF " CS-B CRLF])
(GTRANSFER
[LAMBDA (GEX NEWGP)
(DECRB CS-B CS-P GEX)
(AND (ENSURE CS-B (SETQ GTEMP4 (GLUE CS-P NEWGP)))
(INCRB CS-B GTEMP4 GEX])
(IN-FACTOR
[LAMBDA (N)
(IQUOTIENT N 5])
(INCRB
[LAMBDA (B P X I)
(AND X (OR (AND (SETQ I (OR (GETB B P)
(INIT-PART B P)))
(NCONC1 I X))
(SETB B P (LIST X])
(INIT-PART
[LAMBDA (B P)
(OR (GETB B P)
(SETB B P (COPY (GETB (GLUE (QUOTE ANYB)
P)
(QUOTE INIT])
(INSTAN-1D
[LAMBDA (D BASE REC PAT P SFN DTYP DBOD CR CC CARGS CB CBX LOSE LTIME)
(MATCH D WITH (SFN←&
DTYP←$
DBOD←&))
(SELECTQ (CAR DTYP)
[RECURSIVE (AND [OR (MATCH DBOD WITH ('OR BASE←$
REC←&))
(MATCH DBOD WITH ('COND BASE←$
(REC←&)))
(MATCH DBOD WITH ((QUOTE COND)
BASE←$
((QUOTE T)
REC←$]
(NCONC (INSTAN-BASE BASE)
(INSTAN-REC REC]
[NONRECURSIVE (OR (AND (MATCH DBOD WITH ('MATCH 'BA1 'WITH PAT←&))
(INSTAN-PAT PAT))
(AND (MATCH DBOD WITH (&@[LAMBDA (Z)
(OR (EQ Z (QUOTE EQ))
(EQ Z (QUOTE EQUAL]
CR←&
CC←&))
(CR-INVERT CR CC))
(AND (EQUAL (CAR DBOD)
(QUOTE AND))
(SIMULT-SATISFY (CDR DBOD]
[TRANSFORM (OR (AND (MATCH DBOD WITH ('AND CC←$
('APPLYB ('QUOTE CB←&@IS-CON)
('QUOTE 'DEFN)
CARGS←$)))
(* This is where all the thinking goes. Where do i get the right stuff to put in...
do i go from the reduced-to BEING, and check to see if it meets the new requirements, etc.)
[EVERY (ANY1OFE (GETB CS-B (QUOTE D-R)))
(FUNCTION (LAMBDA (BB)
(OR (GETB BB (QUOTE EXS))
(APPLY* (QUOTE EXS)
BB)
(PROGN [ADD-CANDS (LIST (LIST (AVG2 100 CS-INT)
(QUOTE FILLIN)
BB
(QUOTE EXS]
(SETQ LOSE T]
(SETQ LTIME (ITIMES -1 (CLOCK 2)))
(PROG NIL
L5 [MAP2C BA-LIST (ANY1OFE (GETB CS-B (QUOTE D-R)))
(FUNCTION (LAMBDA (BA BB)
(SET BA (RAND-MEMB (OR (GETB BB (QUOTE EXS))
(APPLY* (QUOTE EXS)
BB]
(COND
([AND (EVERY CC (QUOTE EVAL))
(SETQ TMP9 (SOMEE (GETB CB (QUOTE DEFN))
(QUOTE INSTAN-1D]
(CPRIN1 9 " In instantiating the definition of " CS-B
",
which actually is just that of " CB ", plus " (LENGTH CC)
" new
constraints, AM has in fact found an example.")
(CPRIN1 10 " in " (QUOTIENT (PLUS LTIME (CLOCK 2))
1000.0)
" seconds." CRLF " The example is: " TMP9)
(CPRIN1 9 CRLF)
(RETURN TMP9))
((MINUSP (IPLUS (CLOCK 2)
LTIME -100000))
(GO L5))
(T (CPRIN1 9 " Sorry, AM ran out of time, trying to find an example of" CRLF
CS-B ", which by the way reduces to " CB ", plus " (LENGTH CC)
" new conditions." CRLF)
(RETURN NIL]
(QUASIRECURSIVE NIL)
(BRANCH NIL)
(IMPLICIT NIL)
(CPRIN1 0 CRLF "******* WARNING: NOT A KNOWN TYPE OF DEFN: " D CRLF " EVAL OF CADR OF THIS IS: " P CRLF
"BACK-TRACING: " CRLF (AM-BT)
CRLF])
(INSTAN-1I
[LAMBDA (I)
(GEXADD (ERRORSET I])
(INSTAN-1S
[LAMBDA (S)
NIL])
(INSTAN-BASE
[LAMBDA (BASE BEX)
(SOMEE BASE (FUNCTION (LAMBDA (BASE1)
(AND (LISTP BASE1)
(NULL (CDR BASE1))
(SETQ BASE1 (CAR BASE1)))
(AND (MATCH BASE1 WITH (&@[LAMBDA (Z)
(OR (EQ Z (QUOTE EQ))
(EQ Z (QUOTE EQUAL]
'BA1 BEX←&))
(ERRORSET BEX])
(INSTAN-D
[LAMBDA (DE)
(MAPCONC DE (QUOTE INSTAN-1D])
(INSTAN-I
[LAMBDA (IN)
(MAPCONC (CDR IN)
(QUOTE INSTAN-1I])
(INSTAN-PAT
[LAMBDA (PAT1)
(SETQ PAT1 (COPY PAT1))
(ATTACH (QUOTE LIST)
PAT1)
(DSUBST (LIST (QUOTE RAND-THING))
(QUOTE &)
PAT1)
(SETQ PAT1 (LSUBST (LIST (LIST (QUOTE RAND-THING))
(LIST (QUOTE RAND-THING)))
(QUOTE --)
PAT1))
(SETQ PAT1 (LSUBST (LIST (LIST (QUOTE RAND-THING))
(LIST (QUOTE RAND-THING)))
(QUOTE $)
PAT1)) (* This should be made recursive, on
CAR, it should call itself if LISTP,
else check unpack for ←)
(GEXADD (ERRORSET PAT1])
(INSTAN-REC
[LAMBDA (REC1 DPROC BOP)
(SETQ REC1 (COPY REC1))
(AND (EQ (CAR REC1)
(QUOTE APPLYB))
(EQ (EVAL (CADDR REC1))
(QUOTE DEFN))
(OR (EQ (EVAL (CADR REC1))
CS-B)
(CPRIN1 2 CRLF "Warning from INSTAN-REC: The concept " (CADR REC1)
", which = "
(EVAL (CADR REC1))
" is NOT equal to CS-B, which = " CS-B CRLF)
T)
(SETQ DPROC (CADDDR REC1))
(GEXADD (OR [AND (EQ (CAR DPROC)
(QUOTE APPLYB))
(EQ (EVAL (CADDR DPROC))
(QUOTE ALGS))
(SETQ BOP (EVAL (CADR DPROC)))
(GETHASH BOP HCON)
(LIST (APPLYB BOP (OR (AND (APPLYB (QUOTE CONSTRUCTIVE)
(QUOTE DEFN)
BOP)
'ALGS)
(QUOTE INV))
(CADDDR DPROC)
(CAR (CDDDDR DPROC))
(CADR (CDDDDR DPROC]
(ERRORSET DPROC])
(INSTAN-S
[LAMBDA (SP)
(MAPCONC (CDR SP)
(QUOTE INSTAN-1S])
(INT-ENUF
[LAMBDA (S P IFN)
(SETQ IFN (SELECTQ P
(DEFN (QUOTE IDEF))
(QUOTE IVAL)))
(AND (SETQ NEW-ILEV 0)
[SETQ S (SUBSET (IFEATURES S)
(FUNCTION (LAMBDA (S1)
(AND (SETQ S1 (IFEA S1))
(SETQ TMP3 (EVAL (APPLY* IFN S1)))
(IGREATERP TMP3 INT-THRESH)
(SETQ NEW-ILEV (IPLUS TMP3 NEW-ILEV]
[SETQ NEW-ILEV (AVG2 (CAR (GETB CS-B (QUOTE WORTH)))
(IQUOTIENT NEW-ILEV (LENGTH S]
(MAPCAR S (QUOTE CAADR])
(IS-CON
[LAMBDA (B)
(GETHASH B HCON])
(IS-CON-L
[LAMBDA (B)
(AND (GETHASH B HCON)
(LIST B])
(IS-ONE-OF
[LAMBDA (X XSET)
(AND X XSET (CAR (OR (FMEMB X XSET)
(SOME (RIPPLE X (QUOTE GENL))
(FUNCTION (LAMBDA (Z)
(FMEMB Z XSET])
(ISA
[LAMBDA (BNAME BTYPE)
(COND
((EQ BNAME BTYPE))
(BNAME (SOME (GETB BNAME (QUOTE GENL))
(FUNCTION (LAMBDA (X1)
(ISA X1 BTYPE])
(JUST-ONCE
[NLAMBDA (X X1)
(COND
((SETQ X1 (EVAL X))
(FRPLACA X (QUOTE COND))
(FRPLACD X NIL)
X1])
(KINDS-OF
[LAMBDA (K)
(OR (APPLY* (QUOTE SPEC)
K)
(SUBSET CONCEPTS (FUNCTION (LAMBDA (KC)
(FMEMB K (APPLYB KC (QUOTE GENL])
(LESS-INT
[LAMBDA (A B)
(ILESSP (CAR A)
(CAR B])
(LRU-TAG
[LAMBDA (B)
(PUTU B (QUOTE TIME)
(IQUOTIENT (CLOCK 2)
10000])
(M2
[LAMBDA NIL
(SETQ CAND (LIST 0))
(MAPC CANDS (FUNCTION (LAMBDA (Z)
(OR (ILESSP (CAR Z)
(CAR CAND))
(SETQ CAND Z])
(MAPAPPEND
[LAMBDA (XSET F)
(APPLY (QUOTE APPEND)
(MAPCAR XSET F])
(MAX
[LAMBDA (MSET MPAR)
(COND
[MSET (CAR (SORT (MAPCAR MSET MPAR]
(T -1])
(MAX1
[LAMBDA (MSET MPAR MB1)
(CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
(APPLYB MB1 MPAR MS1])
(MAX2
[LAMBDA (X1 X2 F MVAL MCAN)
(SETQ MVAL -1)
[MAP2C X1 X2 (FUNCTION (LAMBDA (Z1 Z2 TMV)
(AND (SETQ TMV (APPLY* F Z1 Z2))
(ILESSP MVAL TMV)
(SETQ MVAL TMV)
(SETQ MCAN (LIST Z1 Z2 TMV]
(CONS MVAL MCAN])
(MIN2
[LAMBDA (X1 X2 F MVAL MCAN)
(SETQ MVAL 1000)
[MAP2C X1 X2 (FUNCTION (LAMBDA (Z1 Z2 TMV)
(AND (SETQ TMV (APPLY* F Z1 Z2))
(ILESSP TMV MVAL)
(SETQ MVAL TMV)
(SETQ MCAN (LIST Z1 Z2 TMV]
MCAN])
(MKSWAPP
[LAMBDA (FNAME CDEF)
(NOT (MEMB FNAME (CDAR TOP4COMS])
(MORE-GENERAL
[LAMBDA (B1 B2)
(COND
((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
B2)
((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
B1)
(T NIL])
(MORE-INT
[LAMBDA (A B)
(IGREATERP (CAR A)
(CAR B])
(MORE-SPECIFIC
[LAMBDA (B1 B2)
(COND
((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
B1)
((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
B2)
(T NIL])
(NCONCB
[LAMBDA (B P X)
(AND X (SETB B P (UNION (OR (GETB B P)
(INIT-PART B P))
X])
(ONE-ISA
[LAMBDA (XSET X)
(AND X (CAR (SOME XSET (FUNCTION (LAMBDA (X1)
(ISA X1 X])
(ONLY-COMS
[LAMBDA (L)
(EVERY L (FUNCTION (LAMBDA (L1)
(EQ (CAR L1)
(QUOTE COMMENT])
(PGET
[LAMBDA (P B)
(MAPCONC (RIPPLE-SIMULT B (GETP P (QUOTE CENT)))
(QUOTE GETB-P-C])
(PICK-CAND
[LAMBDA NIL
(PROG NIL
P1 (M2)
(COND
((ILESSP (CAR CAND)
DO-THRESH)
(DE-THRESH)
(FIND-NEW-CANDS)
(GO P1)))
(CPRIN1 5 "NEW CAND = " CAND)
(COND
((DREMOVE CAND CANDS))
((SETQ CANDS CAND-TAIL)))
(COND
((RECENTLY-TRIED CAND)
(CPRIN1 3 " REPEATER CAND SKIPPED " CRLF)
(DE-THRESH)
(AND (ZEROP DO-THRESH)
(DIE " DO-THRESH IDENTICALLY ZERO "))
(RPLACINT CAND (SETQ GTEMP1 (IQUOTIENT (CINT CAND)
6)))
(COND
((IGREATERP GTEMP1 INTHRESH)
(ATTACH CAND CANDS)
(ATTACH (QUOTE ONCE)
(RECENTLY-TRIED CAND))
(CPRIN1 3 " FOR NOW. " CRLF))
(T (CPRIN1 3 " FOR THE FORSEEABLE FUTURE. " CRLF)))
(GO P1))
((AND (SETQ CS-OP (COP CAND))
(SETQ CS-B (CB CAND))
(SETQ CS-P (CP CAND))
(ENSURE-TOP))
(SETQ CS-INT (CINT CAND))
(SETQ CS-ACT (CACT CAND))
(SETQ GEXISTING (GETB CS-B CS-P))
(RETURN CAND)))
(GO P1])
(POR
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (REVERSE (RIPPLE-SIMULT B C1)))
(INIT-PART B P)
(SOME-EBP RS P BA1 BA2 BA3 BA4])
(PRUNABLE
[LAMBDA (C)
(NOT (ILESSP INTHRESH (CINT C])
(PRUNE
[LAMBDA (N)
(SETQ CANDS (SUBSET CANDS (QUOTE UNPRUNABLE])
(PSUF
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1 PP)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (RIPPLE-SIMULT B C1))
(SETQ PP P)
(OR (AND BA1 (FMEMB P STRATEGY-PARTS)
(FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (INIT-PART B PP))
(NCONCB B PP (NCONC (SETQ P (GETHASH P SUF1))
(MAPCONC RS (QUOTE APPLYB-P))
(SETQ P (GETHASH P SWSUF))
(MAPCONC (DREVERSE RS)
(QUOTE APPLYB-P])
(PUTB
[LAMBDA (B P Q)
(COND
(Q (PUT B P Q))
(T (REMPROP B P])
(PUTU
[LAMBDA (B PROP PVAL)
(COND
((CAR (ERRORSET B))
(PUTL (EVAL B)
PROP PVAL))
(T (SET B (LIST PROP PVAL])
(PXEQ
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1 PP)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (RIPPLE-SIMULT B C1))
(SETQ PP P)
(OR (AND BA1 (FMEMB P STRATEGY-PARTS)
(FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (INIT-PART B PP))
(NCONCB B PP (MAPCONC RS (QUOTE APPLYB-P])
(Q
[NLAMBDA (X)
(LIST (QUOTE QUOTE)
X])
(RAND-CON
[LAMBDA NIL
(SETQ RANC (GETHASH RANC CIRC])
(RAND-MEMB
[LAMBDA (S)
(AND (LISTP S)
(CAR (FNTH S (RAND 1 (LENGTH S])
(RAND-OBJ
[LAMBDA NIL
(CAR (OR (SETQ OBJX (CDR OBJX))
(SETQ OBJX (EXS OBJECT])
(RAND-PERMUTE
[LAMBDA (L L1 M)
(ANY1OF [AND (SETQ L (COPY L))
(CONS (SETQ L1 (RAND-MEMB L))
(RAND-PERMUTE (DREMOVE L1 L]
(PROGN (SETQ M (LIST T))
[MAPC L (FUNCTION (LAMBDA (L1)
(ATTACH L1 (FNTH M (RAND 1 (LENGTH M]
(CDR (DREVERSE M])
(RAND-PRED
[LAMBDA NIL
(ZEROP (RAND 0 1])
(RAND-SUBSET
[LAMBDA (S)
(SUBSET S (QUOTE RAND-PRED])
(RAND-THING
[LAMBDA NIL
(APPLY (GETHASH RANF CIRC])
(RAND-USER
[LAMBDA NIL
(SETQ RANU (GETHASH RANU CIRC])
(RE-JUDGE
[NLAMBDA (RJ I1)
(CPRIN1 8 " SUPPOSED TO RE-JUDGE " RJ CRLF)
(AND [SETQ I1 (ERSETQ (APPLY* (CAR RJ)
(QUOTE C-INT)
(EVAL RJ]
(NUMBERP I1)
(IGREATERP I1 EX-THRESH)
(CREATEB RJ])
(RECENTLY-TRIED
[LAMBDA (C)
(SASSOC (CDR C)
PAST])
(RECTANGLE
[LAMBDA (X1 X2 Y1 Y2)
(COND
((IGREATERP X1 X2)
(SWITCH X1 X2)))
(COND
((IGREATERP Y1 Y2)
(SWITCH Y1 Y2)))
(FOR I1 FROM X1 TO X2 JOIN (FOR I2 FROM Y1 TO Y2 COLLECT (PACK (LIST (QUOTE R)
I1
(QUOTE -)
I2])
(REM-ONCE
[LAMBDA (X L)
(AND L (OR (AND (EQ (CAR L)
X)
(CDR L))
(CONS (CAR L)
(REM-ONCE X (CDR L])
(RIPPLE
[LAMBDA (ATYPE XTR-PART)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE)))
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NEW))
(GO L1])
(RIPPLE-SIMULT
[LAMBDA (ATYPE DIRS)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE)))
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC DIRS (FUNCTION (LAMBDA (XTR-PART)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NEW))
(GO L1])
(RIPPLE-UNTIL
[LAMBDA (ATYPE XTR-PART PRED)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE))
RVAL)
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND [SETQ RVAL (CAR (SOME OLD (LIST (QUOTE LAMBDA)
(LIST (QUOTE B))
PRED]
(RETURN RVAL))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NIL))
(GO L1])
(RIPPLE1
[LAMBDA (B4 P4 DIR RTEMP)
(COND
((LISTP B4)
(SETQ GXTR-PART P4)
[SOME (XTR-BEING B4)
(FUNCTION (LAMBDA (B5)
(SETQ RTEM2 (RIPPLE1 B5 P4 DIR]
RTEM2)
((GETHASH (SETQ RTEMP (GLUE B4 P4))
HCON)
RTEMP)
((GETHASH B4 HCON)
(RIPPLE1 (GETB B4 DIR)
P4 DIR])
(RMUL
[LAMBDA (AMUL IMUL JMUL)
(ITIMES IMUL (IQUOTIENT AMUL JMUL])
(SAME-TYPE
[LAMBDA (B1 B2 BTYP)
(OR (AND (EQ B1 BTYP)
(EQ B2 B1)
B1)
(CADR (MEMB BTYP (COM-ANCES B1 B2])
(SATISFIES
[LAMBDA NIL NIL])
(SELF
[NLAMBDA (X)
(SET X X])
(SELF-COMPILE
[NLAMBDA (BP C AL)
(SETQ LAPFLG NIL)
(SETQ SVFLG NIL)
(SETQ STRF T)
(COMPILE1 BP (LIST (QUOTE LAMBDA)
(SETQ AL (ARGLIST BP))
C))
(EVAL (CONS BP AL])
(SEQX
[LAMBDA (X1)
(OR (EQUAL X1 (CAR X))
(APPLYB (QUOTE STRUCTURE-EQUAL)
(QUOTE ALGS)
(APPEND (CAR X))
(APPEND X1])
(SET-DIFF
[LAMBDA (L M)
(ANY1OF (PROGN (SETQ L (APPEND L))
[MAPC M (FUNCTION (LAMBDA (M1)
(DREMOVE M1 L]
L)
(SUBSET L (FUNCTION (LAMBDA (L1)
(NOT (FMEMB L1 M])
(SET-NTH
[LAMBDA (S N X I)
(COND
((FNTH S N)
(CAR (FRPLACA (FNTH S N)
X)))
((CDR S)
(FOR I FROM (ADD1 (LENGTH S)) TO N DO (NCONC1 S 0))
(CAR (FRPLACA (FNTH S N)
X])
(SETB
[LAMBDA (B P Q BP)
(AND (FMEMB P XEQ-PARTS)
Q
(PUTD (SETQ BP (GLUEE B P))
(LIST (QUOTE LAMBDA)
(GETARGS P)
(LIST (QUOTE SELF-COMPILE)
BP Q)))
(NOT (GETB B P))
(ATTACH (LIST P (CONS BP (GETARGS P)))
(BPFS B)))
(PUT B P Q])
(SETBQ
[NLAMBDA (B P Q)
(SETB B P (EVAL Q])
(SIMULT-SATISFY
[LAMBDA (GLIST)
[MAPC GLIST (FUNCTION (LAMBDA (G BA BN XPR BN2)
(SETQ GTEMP6 (COND
[[MATCH G WITH ('ISA BA←&@[LAMBDA (Z)
(MATCH (UNPACK Z) WITH ('B 'A &@NUMBERP]
BN←&@(LAMBDA (Z)
(GETHASH (SETQ BN2 (CAR (ERRORSET Z)))
HCON]
[SETQ TMP8 (OR (SUBSET (GETB BN2 (QUOTE EXS))
(QUOTE ATOM))
(SUBSET (APPLY* (QUOTE EXS)
BN2)
(QUOTE ATOM]
(OR (AND (ERRORSET BA)
(ISA (EVAL BA)
BN2))
(SET BA (RAND-MEMB TMP8]
((MATCH G WITH ('ARE-EQUIV BA←&@[LAMBDA (Z)
(MATCH (UNPACK Z) WITH ('B 'A &@NUMBERP]
XPR←&))
(SET BA (CAR (ERRORSET XPR]
(* Actually, to be truly "simult", we must re-check our earlier goals after each new one is
satisfied, and perhaps we should initially select the "hardest" one to satisfy first, etc,)
(LIST GTEMP6])
(SOME-EBP
[LAMBDA (L P BA1 BA2 BA3 BA4)
(AND L (OR (APPLYB (CAR L)
P BA1 BA2 BA3 BA4)
(SOME-EBP (CDR L)
P BA1 BA2 BA3 BA4])
(SOMEE
[LAMBDA (XSET FN)
(PROG (V)
L1 (COND
((SETQ V (APPLY* FN (CAR XSET)))
(RETURN V))
((SETQ XSET (CDR XSET))
(GO L1))
((RETURN NIL])
(SORD
[LAMBDA (X Y)
(AND (ALPHORDER X Y)
(OR (NLISTP X)
(NLISTP Y)
(EQUAL X Y)
(COND
((EQUAL (CAR X)
(CAR Y))
(SORD (CDR X)
(CDR Y)))
((SORD (CAR X)
(CAR Y])
(SSORT
[LAMBDA (Z)
(SORT (CDR Z)
(QUOTE SORD])
(START
[LAMBDA NIL
(SETQ PKNT 0)
(SETQ DO-THRESH INIT-DOTHRESH)
(SETQ EX-THRESH INIT-EXTHRESH)
(SETQ INT-THRESH INIT-INT-THRESH)
(SETQ INTHRESH INIT-INTHRESH)
(SETQ CANDS (COPY INIT-CANDS))
(SETQ PAST (COPY INIT-PAST))
(TERPRI)
(PRIN1 "ENTERING MAIN LOOP NOW.")
(TERPRI)
(TERPRI)
(TLOOP)
(TERPRI)
(PRIN1 "RE-")
(START])
(SUB-CANDS
[LAMBDA (SL)
[MAPC SL (FUNCTION (LAMBDA (S)
(SOME CANDS (FUNCTION (LAMBDA (C)
(AND (EQUAL (CACT C)
(CACT S))
(RPLACA C (IQUOTIENT (CINT C)
2] (* This is rather an inefficient way to
do this.)
CANDS])
(SUB-ONCE
[LAMBDA (X Y L)
(AND L (OR (AND (EQ (CAR L)
Y)
(CONS X (CDR L)))
(CONS (CAR L)
(SUB-ONCE X Y (CDR L])
(SUBSET-INVOLVING-ONLY
[LAMBDA (XSET V)
(SETQ V (REMOVE V BA-LIST2))
(CONS (QUOTE AND)
(SUBSET XSET (FUNCTION (LAMBDA (X)
(NOT (INTERSECTION V (FLATTEN X])
(SWAPB
[LAMBDA (B PFILE)
(COND
((GETU B (QUOTE FOUT)))
((PUTU B (QUOTE FOUT)
(LIST (SETQ PFILE (GETPROPERFILE))
(GETPROPERFILEPOS)))
(PRIN2 (GETPROPLIST B)
PFILE)))
(COND
((FMEMB B NOSWAP-CONCEPTS))
((SETPROPLIST B 0])
(SWGETB
[LAMBDA (B P F)
(LRU-TAG B)
(COND
((GET B P))
((ZEROP (GETPROPLIST B))
(SETQ F (GETU B (QUOTE FOUT)))
[COND
((ATOM F)
(LOADVARS (LIST (LIST (QUOTE (QUOTE PUTPROPS))
(KWOTE B)
(QUOTE $)))
F T))
(T (SETFILEPTR (CAR F)
(CADR F]
(SETQ B (READ (CAR F)))
(GET B P])
(SWITCH
[NLAMBDA (C1 C2 CTEMP)
(SETQ CTEMP (EVAL C1))
(SET C1 (EVAL C2))
(SET C2 CTEMP])
(SWSETB
[LAMBDA (B P Q BP)
(AND (FMEMB P XEQ-PARTS)
(PUTD (SETQ BP (GLUEE B P))
(LIST (QUOTE LAMBDA)
(GETARGS P)
(LIST (QUOTE SELF-COMPILE)
BP Q)))
(NOT (GETB B P))
(ATTACH (NCONC (LIST P (LIST BP))
(GETARGS P))
(BPFS B)))
(AND (GETU B (QUOTE FOUT))
(PUTU B (QUOTE FOUT)
NIL))
(LRU-TAG B)
(PUT B P Q])
(TLOOP
[LAMBDA NIL
(TERPRI)
(PRIN1 "VERBOSITY LEVEL (0-10) ... ")
(SETQ VERBOSITY (RATOM))
(PROG NIL
L1 (PICK-CAND)
(XEQ-CAND)
(UPDATE)
(GO L1])
(TYPE
[NLAMBDA X
(EVAL (CAR (FLAST X])
(UNDO-INIT
[LAMBDA (P L)
(COND
((GETP P (QUOTE UNDO-INIT))
(APPLY* (GETP P (QUOTE UNDO-INIT))
L))
(L])
(UNFORGETTABLE
[LAMBDA (B P I F ARG1)
(* Each C-SUGGESTS part is ordered: first, when to definitely reject recognition;
next, when to definitely accept it. If it accepts, the being decides on part P, interest level I,
function to do to it F, and then returns (I F (B P args)))
(APPLYB B (QUOTE SUGG)
INTHRESH])
(UNPRUNABLE
[LAMBDA (C)
(ILESSP INTHRESH (CAR C])
(UP-THRESH
[LAMBDA NIL
(SETQ DO-THRESH (IQUOTIENT (IPLUS DO-THRESH (CINT CAND))
2])
(UPDATE
[LAMBDA NIL
(UP-THRESH)
(SETQ INTHRESH (IN-FACTOR DO-THRESH))
(CPRIN1 9 CRLF "The final value returned by this candidate was: " CVAL CRLF)
(PRUNE INTHRESH)
(SETQ PAST (CONS (CONS (CDR CAND)
CVAL)
(DREMOVE (CAR (FLAST PAST))
PAST])
(XEQ-CAND
[LAMBDA NIL
(SETQ CVAL (EVAL CS-ACT])
(XTR-BEING
[LAMBDA (B) (* This actually will depend on the
format of the part being worked on.
This part is to be assigned to the
variable XTR-PART)
(COND
((ATOM B)
(AND (GETHASH B HCON)
(LIST B)))
((LISTP B)
(COND
((EQUAL (CAR B)
(QUOTE OR-RUN:))
(EVAL (CADR B)))
(T (MAPCONC B (QUOTE XTR-BEING])
)
(DEFINEQ
(INIT1
[LAMBDA NIL
(CLDISABLE (QUOTE -))
(WIDEPAPER T)
(RAISE)
[INTERRUPTCHAR 24 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** BACKTRACING:")
(TERPRI)
(AM-BT)
(TERPRI)
(PRIN1 "*** END OF BACKTRACE")
(TERPRI]
[INTERRUPTCHAR 25 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** NUMBER OF CANDS IS ")
(PRINT (LENGTH CANDS]
[INTERRUPTCHAR 26 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** INTEREST ")
(PRIN1 DO-THRESH)
(PRIN1 ", ")
(PRIN1 INTHRESH)
(PRIN1 ", NCANDS=")
(PRIN1 (LENGTH CANDS))
(PRIN1 ", CAND=")
(PRINT CAND]
(TERPRI)
(PRIN1 "YOU PROBABLY WANT TO LOAD IN THE FILE CON4 NOW")
(RANDSET RANDSTATE)
(TERPRI])
(INIT-COMP
[LAMBDA NIL
[COND
((NOT (GETD (QUOTE GETTOPVAL)))
(MOVD (QUOTE CAR)
(QUOTE GETTOPVAL))
(MOVD (QUOTE CDR)
(QUOTE GETPROPLIST))
[PUTD (QUOTE SETTOPVAL)
(QUOTE (LAMBDA (X Y)
(CAR (FRPLACA X Y]
[PUTD (QUOTE SETPROPLIST)
(QUOTE (LAMBDA (X Y)
(CDR (FRPLACD X Y]
[PUTD (QUOTE /SETTOPVAL)
(QUOTE (LAMBDA (X Y)
(CAR (/RPLACA X Y]
[PUTD (QUOTE /SETPROPLIST)
(QUOTE (LAMBDA (X Y)
(CDR (/RPLACD X Y]
(NCONC LISPXFNS (QUOTE ((SETTOPVAL . /SETTOPVAL)
(SETPROPLIST . /SETPROPLIST]
[COND
((NOT (GETD (QUOTE GETFILEPTR)))
(MOVD (QUOTE SFPTR)
(QUOTE GETFILEPTR))
(PUTD (QUOTE SETFILEPTR)
(QUOTE (LAMBDA (FILE PTR)
(PROG1 PTR (SFPTR FILE PTR]
(DEFLIST [QUOTE ((GETTOPVAL ((X)
(CAR X)))
(GETPROPLIST ((X)
(CDR X]
(QUOTE MACRO])
)
(RPAQQ BA-LIST (BA1 BA2 BA3 BA4 BA5 BA6 BA7 BA8 BA9))
(RPAQQ BA-LIST2 (BA1 BA2 BA3))
[RPAQQ CAND-TAIL ((0 PRINT (QUOTE TAIL-MARK]
(RPAQQ COMMA ", ")
(RPAQQ CONSTRUCTIVE-OPS (STRUCTURE-INSERT UNION NCONC ATTACH MAPSTRUC CONS UNITE APPEND LIST))
(RPAQQ CRLF "
")
(RPAQQ DO-THRESH 101)
(RPAQQ DWIMUSERFN T)
(RPAQQ EX-THRESH 500)
(RPAQQ F-COUNTER 0)
[RPAQQ INIT-CANDS ((0 PRIN1 (QUOTE TAIL-MARK]
(RPAQQ INIT-ONCE-LIST (ANYB ANYP))
(RPAQQ INIT-PAST ((A B)
(C D)
(E F)
(G H)
(I J)
(K L)
(M N)
(O P)
(Q R)
(S T)
(U V)
(W X)
(Y Z)
(AA BB)
(CC DD)
(EE FF)))
(RPAQQ INIT-DOTHRESH 500)
(RPAQQ INIT-EXTHRESH 500)
(RPAQQ INIT-INT-THRESH 279)
(RPAQQ INIT-INTHRESH 100)
(RPAQQ INT-THRESH 279)
(RPAQQ INTHRESH 20)
(RPAQQ JTRASH (JUST-ONCE (COND)))
(RPAQQ RANDSTATE (-27930175794 . 1281409132))
(RPAQQ TOP-ACTS (ACCESS ADD-CANDS CHECK EVAL EXPR-IN FILLIN GOAL INIT-PART INSTANTIATE PRIN1 PRINT RE-JUDGE RESTRUC
SUB-CANDS TRANSLATE))
(RPAQQ TRIVB [LAMBDA (BP BA1 BA2 BA3 BA4)
(SELECTQ BP NIL])
(RPAQQ USERNAMES (AVRA BRUCE CORDELL DOUG ED))
(RPAQQ VERBOSITY 11)
(INIT1)
(INIT-COMP)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TYPE COMMENT ANY1OF)
(ADDTOVAR NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE Q JUST-ONCE GETBQ ANY1SAT ALLQ)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (2242 34801 (ACCESS 2254 . 2285) (ADD-CANDS 2289 . 2348) (ALL-BUT-LAST 2352 . 2405) (ALLQ 2409 . 2531)
(ANY1OF 2535 . 2666) (ANY1OF-SATISFYING 2670 . 2819) (ANY1OFE 2823 . 2860) (ANY1SAT 2864 . 2947) (APPLYB-P 2951 .
3010) (ARE-EQUIV 3014 . 3604) (ARG-CHECK 3608 . 3709) (ARG-SUBST 3713 . 4165) (ARGS-ASA 4169 . 4473) (AVG2 4477 .
4544) (BPFS 4548 . 4596) (CLEAN 4600 . 4892) (CLEANALL 4896 . 5049) (COM-ANCES 5053 . 5290) (COMMENT 5294 . 5351)
(CON-MERGE-ARGS 5355 . 7090) (CPRIN1 7094 . 7219) (CREATEB 7223 . 7435) (DE-THRESH 7439 . 7605) (DECRB 7609 . 7669)
(DEFB 7673 . 8200) (DEFP 8204 . 8872) (DIE 8876 . 9001) (DOTPROD 9005 . 9148) (DWIMUSERFN 9152 . 9508) (ENSURE 9512
. 9799) (ENSURE-TOP 9803 . 10119) (EVERY2 10123 . 10271) (FAN 10275 . 10389) (FIND-NEW-CANDS 10393 . 10568) (FIRSTN
10572 . 10628) (FLATTEN 10632 . 10733) (FRAC-INCLU 10737 . 10998) (FSET-NTH 11002 . 11069) (GATH 11073 . 11435) (GCB
11439 . 11735) (GEN-FNAME 11739 . 11866) (GET-TIME 11870 . 11921) (GETARGS 11925 . 11975) (GETB 11979 . 12031) (GETB-P
12035 . 12074) (GETB-P-C 12078 . 12125) (GETBQ 12129 . 12170) (GETU 12174 . 12233) (GEXADD 12237 . 12310) (GEXEC 12314
. 12361) (GLUE 12365 . 12571) (GLUEC 12575 . 12661) (GLUEE 12665 . 12874) (GPGM-PRIN 12878 . 13350) (GTRANSFER 13354
. 13498) (IN-FACTOR 13502 . 13549) (INCRB 13553 . 13697) (INIT-PART 13701 . 13827) (INSTAN-1D 13831 . 16618) (INSTAN-1I
16622 . 16674) (INSTAN-1S 16678 . 16714) (INSTAN-BASE 16718 . 17033) (INSTAN-D 17037 . 17098) (INSTAN-I 17102 . 17176)
(INSTAN-PAT 17180 . 17805) (INSTAN-REC 17809 . 18654) (INSTAN-S 18658 . 18732) (INT-ENUF 18736 . 19216) (IS-CON 19220
. 19265) (IS-CON-L 19269 . 19333) (IS-ONE-OF 19337 . 19500) (ISA 19504 . 19671) (JUST-ONCE 19675 . 19794) (KINDS-OF
19798 . 19941) (LESS-INT 19945 . 20007) (LRU-TAG 20011 . 20101) (M2 20105 . 20254) (MAPAPPEND 20258 . 20337) (MAX
20341 . 20437) (MAX1 20441 . 20556) (MAX2 20560 . 20812) (MIN2 20816 . 21059) (MKSWAPP 21063 . 21134) (MORE-GENERAL
21138 . 21295) (MORE-INT 21299 . 21367) (MORE-SPECIFIC 21371 . 21529) (NCONCB 21533 . 21637) (ONE-ISA 21641 . 21738)
(ONLY-COMS 21742 . 21849) (PGET 21853 . 21954) (PICK-CAND 21958 . 23021) (POR 23025 . 23211) (PRUNABLE 23215 . 23276)
(PRUNE 23280 . 23352) (PSUF 23356 . 24003) (PUTB 24007 . 24090) (PUTU 24094 . 24234) (PXEQ 24238 . 24746) (Q 24750
. 24801) (RAND-CON 24805 . 24866) (RAND-MEMB 24870 . 24951) (RAND-OBJ 24955 . 25048) (RAND-PERMUTE 25052 . 25334)
(RAND-PRED 25338 . 25387) (RAND-SUBSET 25391 . 25452) (RAND-THING 25456 . 25515) (RAND-USER 25519 . 25581) (RE-JUDGE
25585 . 25806) (RECENTLY-TRIED 25810 . 25874) (RECTANGLE 25878 . 26160) (REM-ONCE 26164 . 26298) (RIPPLE 26302 . 26660)
(RIPPLE-SIMULT 26664 . 27076) (RIPPLE-UNTIL 27080 . 27595) (RIPPLE1 27599 . 27913) (RMUL 27917 . 27991) (SAME-TYPE
27995 . 28123) (SATISFIES 28127 . 28158) (SELF 28162 . 28199) (SELF-COMPILE 28203 . 28413) (SEQX 28417 . 28552) (
SET-DIFF 28556 . 28754) (SET-NTH 28758 . 28968) (SETB 28972 . 29260) (SETBQ 29264 . 29315) (SIMULT-SATISFY 29319 .
30242) (SOME-EBP 30246 . 30401) (SOMEE 30405 . 30591) (SORD 30595 . 30835) (SSORT 30839 . 30897) (START 30901 . 31298)
(SUB-CANDS 31302 . 31603) (SUB-ONCE 31607 . 31754) (SUBSET-INVOLVING-ONLY 31758 . 31939) (SWAPB 31943 . 32226) (SWGETB
32230 . 32574) (SWITCH 32578 . 32684) (SWSETB 32688 . 33073) (TLOOP 33077 . 33286) (TYPE 33290 . 33336) (UNDO-INIT
33340 . 33469) (UNFORGETTABLE 33473 . 33823) (UNPRUNABLE 33827 . 33884) (UP-THRESH 33888 . 33990) (UPDATE 33994 .
34285) (XEQ-CAND 34289 . 34344) (XTR-BEING 34348 . 34798)) (34803 36514 (INIT1 34815 . 35591) (INIT-COMP 35595 . 36511))))
)
STOP